pq_label_review

STEP 3 - Review results from DTM_inferLDATopics_LabelCorpus

This notebook: 1. Reads in labeled outputs from 04_pq_model.Rmd (“04_pq_labels.csv”) 2. Joins “04_pq_labels.csv” with “01_pq_metaclean.csv” 3. Subsets dataset based on labels and percent probabilities 4. Writes subsets to CSVs

Notes

1. “SUBSETTING” keyword for searching 05_pq_label_review.Rmd

#load data
# 01_pq_metaclean.csv
pq_metaclean <- data.table::fread('Data/02_Working/01_pq_metaclean.csv')
# read in columns as characters so that doc id does not read in as numeric
# 04_pq_labels.csv
pq_labels <- data.table::fread(paste0('Data/02_Working/',rFileModelNum,'_pq_labels.csv'), colClasses = 'character')

# Head displays the first 6 rows of the data.table
#head(pq_metaclean)
#head(pq_labels)

# displays column names
print("pq_metaclean columns:")

[1] "pq_metaclean columns:"

names(pq_metaclean)

 [1] "Title"                   "Publication title"       "Publication year"        "Document URL"            "Full text"              
 [6] "Links"                   "Section"                 "Publication subject"     "ISSN"                    "Copyright"              
[11] "Abstract"                "Publication info"        "Last updated"            "Place of publication"    "Location"               
[16] "Author"                  "Publisher"               "Identifier / keyword"    "Source type"             "ProQuest document ID"   
[21] "Country of publication"  "Language of publication" "Publication date"        "Subject"                 "Database"               
[26] "Document type"          

print("")

[1] ""

print("pq_labels columns:")

[1] "pq_labels columns:"

names(pq_labels)

[1] "document" "topic"    "val"     

nrow(pq_metaclean);nrow(pq_labels)

[1] 6239
[1] 4881

join cleaned dataset with labels

# join tables
# inner_join because pq_metaclean was subset based on topic 2 when the model was re-ran in "04_pq_model.Rmd"
# so we only want where the Proquest ID exists in both the original dataset and the labels.
pq_metajoin <- pq_labels %>% 
  inner_join(pq_metaclean, by = c("document" = "ProQuest document ID"))

pq_metajoin <- pq_metajoin %>%
  rename(`ProQuest document ID` = document)

nrow(pq_metajoin);head(pq_metajoin)

[1] 4880

pq_empty<-pq_metajoin[pq_metajoin$topic == "" | is.na(pq_metajoin$topic),]
nrow(pq_empty)

[1] 0

# write labeled corpus to CSV
outputFileName = "pq_topics"
outputFile = paste(outputFolder,rFileNum,"_",outputFileName,".xlsx",sep="")
write.xlsx(pq_metajoin, outputFile, row.names=FALSE)
#write.htmltable(pq_metajoin,title=outputFile, outputFile, sortby="topic","val")

Code now ready for SUBSETTING if you want to skip the following sections –

exploratory data analysis of topics generated

Do we want to keep both topics, or drop one of the topics and dig deeper into the other topic?

number of topics by publication title

plotTitle = "Count of Articles by Topic and Publication Title"

# count by pub title and topic
count_topic_pubtitle <-pq_metajoin %>%
  group_by(`Publication title`,topic) %>% 
  summarise(n= n()) %>%
  arrange(as.numeric(topic),as.numeric(n))

`summarise()` regrouping output by 'Publication title' (override with `.groups` argument)

count_topic_pubtitle

# save plot in png format
outputPNGFileName <- file.path(outputPngFolder,paste0("count_topic_pubtitle.png"))
png(outputPNGFileName,height=6,width=12, units='in', res=300)
ggplot(count_topic_pubtitle, aes(x = as.factor(as.numeric(topic)), y = n, fill = `Publication title`, label = n )) +
  geom_bar(stat = "identity") +
  geom_text(size = 3, position = position_stack(vjust = 0.5)) +
  ggtitle(plotTitle) +
  theme(plot.title = element_text(hjust = 0.5)) +
  xlab("Probability Range") +
  ylab("Article Count") +
  labs(fill = "Topic")
print(paste("Plot saved as:",outputPNGFileName))

[1] "Plot saved as: Images//05_pq_review/count_topic_pubtitle.png"

dev.off()

null device 
          1 

knitr::include_graphics(paste0("Images/",rFileNum,"_pq_review/count_topic_pubtitle.png"))

number of topics by location

Count articles by topic and year

Important to consider the total articles/year in addition to the raw count of articles per topic. Peaks in articles may simply be due to an overall increase of articles for a particular year.

# article count per year and topic
count_topic_year <-pq_metajoin %>%
  group_by(`Publication year`,topic) %>% 
  summarise(n= n()) %>%
  arrange(as.numeric(topic),as.numeric(`Publication year`))

`summarise()` regrouping output by 'Publication year' (override with `.groups` argument)

count_topic_year

# article count per year
count_year <-pq_metajoin %>%
  group_by(`Publication year`) %>% 
  summarise(perYear= n()) %>%
  arrange(as.numeric(`Publication year`))

`summarise()` ungrouping output (override with `.groups` argument)

count_topic_year<-count_topic_year %>%
  left_join(count_year, by = "Publication year")

count_topic_year<-count_topic_year %>%
  mutate(ratio = round(n/perYear,2))

plotTitle = "Count of Articles by Topic and Year"
# save plot in png format
outputPNGFileName <- file.path(outputPngFolder,paste0("count_topic_year.png"))
png(outputPNGFileName,height=5,width=15, units='in', res=300)
ggplot(count_topic_year, aes(x = `Publication year`, colour = as.factor(as.numeric(topic)))) +
  geom_line(aes(y = n)) +
  scale_x_continuous(breaks=seq(min(na.omit(count_topic_year$`Publication year`)), max(na.omit(count_topic_year$`Publication year`)),1)) +
  theme(axis.text.x = element_text(angle = 90),
        plot.title = element_text(hjust = 0.5)) +
  facet_wrap(vars(as.numeric(topic))) +
  ggtitle(plotTitle) +
  xlab("Publication Year") +
  ylab("Article Count") +
  guides(colour=FALSE) 
print(paste("Plot saved as:",outputPNGFileName))

[1] "Plot saved as: Images//05_pq_review/count_topic_year.png"

dev.off()

null device 
          1 

plotTitle = "Count of Articles by Topic and Year with Year Total"
# save plot in png format
outputPNGFileName <- file.path(outputPngFolder,paste0("count_topic_year_tot.png"))
png(outputPNGFileName,height=5,width=15, units='in', res=300)

ggplot(count_topic_year, aes(x = `Publication year`, colour = as.factor(as.numeric(topic)))) +
  geom_line(aes(y = n)) +
  geom_line(linetype = "dashed", color="black", aes(y = perYear)) +
  scale_x_continuous(breaks=seq(min(na.omit(count_topic_year$`Publication year`)), max(na.omit(count_topic_year$`Publication year`)),1)) +
  theme(axis.text.x = element_text(angle = 90),
        plot.title = element_text(hjust = 0.5)) +
  facet_wrap(vars(as.numeric(topic))) +
  ggtitle(plotTitle) +
  xlab("Publication Year") +
  ylab("Article Count") +
  guides(colour=FALSE) 
print(paste("Plot saved as:",outputPNGFileName))

[1] "Plot saved as: Images//05_pq_review/count_topic_year_tot.png"

dev.off()

null device 
          1 

plotTitle = "Ratio of Articles by Topic and Year"
# save plot in png format
outputPNGFileName <- file.path(outputPngFolder,paste0("ratio_topic_year.png"))
png(outputPNGFileName,height=5,width=15, units='in', res=300)

ggplot(count_topic_year, aes(x = `Publication year`, colour = as.factor(as.numeric(topic)))) +
  geom_line(aes(y = ratio)) +
  scale_x_continuous(breaks=seq(min(na.omit(count_topic_year$`Publication year`)), max(na.omit(count_topic_year$`Publication year`)),1)) +
  theme(axis.text.x = element_text(angle = 90),
        plot.title = element_text(hjust = 0.5)) +
  facet_wrap(vars(as.numeric(topic))) +
  ggtitle(plotTitle) +
  xlab("Publication Year") +
  ylab("(Article Count)/(Article Total)") +
  guides(colour=FALSE) 
print(paste("Plot saved as:",outputPNGFileName))

[1] "Plot saved as: Images//05_pq_review/ratio_topic_year.png"

dev.off()

null device 
          1 

knitr::include_graphics(paste0("Images/",rFileNum,"_pq_review/count_topic_year.png"))

knitr::include_graphics(paste0("Images/",rFileNum,"_pq_review/count_topic_year_tot.png"))

knitr::include_graphics(paste0("Images/",rFileNum,"_pq_review/ratio_topic_year.png"))

Coherence score by topic

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/coherence_score_topic.png"))

Wordclouds

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/1_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/2_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/3_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/4_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/5_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/6_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/7_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/8_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/9_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/10_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/11_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/12_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/13_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/14_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/15_lda_topic_wc.png"))

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/16_lda_topic_wc.png"))

Count of Article by Topic

# bar chart
knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/topic_count_bar.png"))

# pie chart
knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/topic_count_pie.png"))

Count of Probabilities by Percentage

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/prob_count.png"))

Count of Topic Probabilities by Percentage

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/prob_topic_count.png"))

#5. Visualising of topics in a dendrogram

knitr::include_graphics(paste0("Images/",rFileModelNum,"_pq_model/hclust_dendrogram.png"))

NA

“Quarantine”

# not_oyster_subset = if not exists in full_corpus {oyster*}
# 1858 articles with the word "oyster"
# 3286 articles without the word "oyster"
pq_metaqtine<- pq_metajoin %>% 
  filter(!stringr::str_detect(`Full text`,"oyster*")) 
print(paste("Number of articles without the word oyster*", nrow(pq_metaqtine)))

[1] "Number of articles without the word oyster* 3120"

head(pq_metaqtine)

# quarantined_subset = if exists in not_oyster_subset {clam* | mussel* | scallop* | lobster*}
#These are the quarantined articles that need to be examined
pq_metaqtine <- pq_metaqtine %>% 
  filter(stringr::str_detect(`Full text`,"clam* | mussel* | scallop* | lobster*"))
print(paste("Number of articles within *not oyster* subset and has the words clam* | mussel* | scallop* | lobster*", nrow(pq_metaqtine)))

[1] "Number of articles within *not oyster* subset and has the words clam* | mussel* | scallop* | lobster* 1422"

pq_metaqtine_ids <- pq_metaqtine %>% select(`ProQuest document ID`)
# corpus_subset = anti_join(quarantined_subset, fullcorpus)

# this is the entire corpus with quarantined articles removed
pq_metafilter_words <- pq_metajoin %>%
  anti_join(pq_metaqtine_ids, by="ProQuest document ID")

numFiltered <- nrow(pq_metajoin)-nrow(pq_metafilter_words)
rm(pq_metaqtine_ids)

print(paste("Number of articles removed based on words:",numFiltered));nrow(pq_metafilter_words)

[1] "Number of articles removed based on words: 1422"
[1] 3459

START SUBSETTING - Subset Function

topic_subset_csv <- function(outputFolderName, rFileNum, outputFileName, inputCorpus, minPerc, maxPerc, theTopic, overwrite)

• outputFolderName = folder to save to – i.e., “Data/02_Working/” (this is set at the top of the code where the libraries are loaded/installed)
• rFileNum = The number in the r file – i.e., “05” (this is set at the top of the code where the libraries are loaded/installed)
• outputFileName = the file name to save as – i.e., “pq_topic5_90perc” (this needs to be set at least 1 line above where the function is ran)
• inputCorpus = the labeled corpus – i.e., pq_metajoin (this is created shortly after where libraries are loaded/installed in review.Rmd by joining pq_metaclean with pq_labels)
• minPerc = minimum percentage – i.e., 0.9 (this needs to be set at least 1 line above where the function is ran)
• maxPerc = maximum percentage – i.e., 1 (this needs to be set at least 1 line above where the function is ran)
• theTopic = the topic category – i.e., “1” (this needs to be set at least 1 line above where the function is ran)
• overwrite = whether to overwrite the file if it already exists – i.e., FALSE (this needs to be set at least 1 line above where the function is ran)

Subset topic 1

# subset corpus to unique identifier & full text of article
# investigate topic 1

outputFileName_1t <- "pq_topic1"
minPerc <- 0
maxPerc <- 1
theTopic <- "1"

## e.g, minPerc = 0 & maxPerc = 0.4 is zero to 0.3999999999 ...
pq_topic1_subset<-topic_subset_csv(outputFolder, rFileNum, outputFileName_1t, pq_metajoin , minPerc, maxPerc, theTopic, overwrite)

Already exists, loading: pq_topic1 

head(pq_topic1_subset);nrow(pq_topic1_subset)

[1] 233

Subset topic 1, 90%

# subset corpus to unique identifier & full text of article
# investigate topic 1, 90%
outputFile_1t90perc <- "pq_topic1_90perc"
minPerc <- 0.9
maxPerc <- 1
theTopic <- "1"

## e.g, minPerc = 0 & maxPerc = 0.4 is zero to 0.3999999999 ...
pq_topic1_90perc<-topic_subset_csv(outputFolder, rFileNum, outputFile_1t90perc, pq_metajoin , minPerc, maxPerc, theTopic, overwrite)

Already exists, loading: pq_topic1_90perc 

head(pq_topic1_90perc);nrow(pq_topic1_90perc)

[1] 55

Subset topic 5, 90%

# subset corpus to unique identifier & full text of article
# investigate topic 1, 90%
outputFile_5t90perc <- "pq_topic5_90perc"
minPerc <- 0.9
maxPerc <- 1
theTopic <- "5"

## e.g, minPerc = 0 & maxPerc = 0.4 is zero to 0.3999999999 ...
pq_topic5_90perc<-topic_subset_csv(outputFolder, rFileNum, outputFile_5t90perc, pq_metajoin , minPerc, maxPerc, theTopic, overwrite)

Already exists, loading: pq_topic5_90perc 

head(pq_topic5_90perc);nrow(pq_topic5_90perc)

[1] 80

Subset 50-60%-ers

# subset corpus to unique identifier & full text of article
# investigate all topics, 50-60%
outputFile_56perc <- "pq_56perc"
minPerc <- 0.5
maxPerc <- 0.6
theTopic <- "all"

## e.g, minPerc = 0 & maxPerc = 0.4 is zero to 0.3999999999 ...
pq_56perc<-topic_subset_csv(outputFolder, rFileNum, outputFile_56perc, pq_metajoin , minPerc, maxPerc, theTopic, overwrite)

Already exists, loading: pq_56perc 

head(pq_56perc);nrow(pq_56perc)

[1] 723

Subset topic 1

max(pq_perc06_subset$val)

[1] "0.59996"

END SUBSETTING

explore term frequencies by year - how do words in our corpus change over time?

Referenced walk-through from: https://cran.r-project.org/web/packages/tidytext/vignettes/tidying_casting.html

# subset corpus to unique identifier & year
pq_time <- pq_metaclean %>% 
  select(`ProQuest document ID`, `Publication year`)

# tokens generated from 04_pq_model.Rmd
outputTokenFile = paste0(rFileModelNum,"_tokens.RData")
tokensFileName = file.path(outputFolder,outputTokenFile)

load(file=tokensFileName)

tokens <- tokens %>% 
  full_join(pq_time, by = c("ProQuest document ID" = "ProQuest document ID")) %>%
  rename(Year = `Publication year`) %>%
  rename(pq_id = `ProQuest document ID`) %>%
  mutate_at(vars(Year), funs(as.integer))

`funs()` is deprecated as of dplyr 0.8.0.
Please use a list of either functions or lambdas: 

  # Simple named list: 
  list(mean = mean, median = median)

  # Auto named with `tibble::lst()`: 
  tibble::lst(mean, median)

  # Using lambdas
  list(~ mean(., trim = .2), ~ median(., na.rm = TRUE))
This warning is displayed once every 8 hours.
Call `lifecycle::last_warnings()` to see where this warning was generated.

rm(pq_time)

outputFreqsFile = paste0(rFileNum,"_tokens_freq")
tokens_freq<-create_ifnot_tokens_freq(outputFolder, outputFreqsFile, tokens, overwrite)

Already exists, loading: 05_tokens_freq 

outputFreqModelFile = paste0(rFileNum,"_freq_models")
freq_models <- create_ifnot_freqmodels(outputFolder, outputFreqModelFile, tokens_freq, overwrite)

Already exists, loading: 05_freq_models 

model results

freq_models %>%
  filter(term == "Year") %>%
  arrange(desc(abs(estimate)))

Models displayed as a volcano plot, which compares the effect size with the significance

freq_models %>%
  mutate(adjusted.p.value = p.adjust(p.value)) %>%
  ggplot(aes(estimate, adjusted.p.value)) +
  geom_point() +
  scale_y_log10() +
  geom_text(aes(label = word), vjust = 1, hjust = 1,
            check_overlap = TRUE) +
  xlab("Estimated change over time") +
  ylab("Adjusted p-value")

Top 6 terms that have changed in frequency over time

freq_models %>%
  top_n(6, abs(estimate)) %>%
  inner_join(tokens_freq) %>%
  ggplot(aes(Year, percent)) +
  geom_point() +
  geom_smooth() +
  facet_wrap(~ word) +
  scale_y_continuous(labels = percent_format()) +
  ylab("Frequency of word in speech")

Joining, by = "word"